home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / dejagnu.lha / dejagnu-1.0.1 / tcl / tclCmdMZ.c < prev    next >
C/C++ Source or Header  |  1993-02-14  |  36KB  |  1,429 lines
  1. /* 
  2.  * tclCmdMZ.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    M to Z.  It contains only commands in the generic core (i.e.
  7.  *    those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright 1987-1991 Regents of the University of California
  10.  * Permission to use, copy, modify, and distribute this
  11.  * software and its documentation for any purpose and without
  12.  * fee is hereby granted, provided that the above copyright
  13.  * notice appear in all copies.  The University of California
  14.  * makes no representations about the suitability of this
  15.  * software for any purpose.  It is provided "as is" without
  16.  * express or implied warranty.
  17.  */
  18.  
  19. #include "tclInt.h"
  20.  
  21. /*
  22.  * Structure used to hold information about variable traces:
  23.  */
  24.  
  25. typedef struct {
  26.     int flags;            /* Operations for which Tcl command is
  27.                  * to be invoked. */
  28.     int length;            /* Number of non-NULL chars. in command. */
  29.     char command[4];        /* Space for Tcl command to invoke.  Actual
  30.                  * size will be as large as necessary to
  31.                  * hold command.  This field must be the
  32.                  * last in the structure, so that it can
  33.                  * be larger than 4 bytes. */
  34. } TraceVarInfo;
  35.  
  36. /*
  37.  * Forward declarations for procedures defined in this file:
  38.  */
  39.  
  40. static char *        TraceVarProc _ANSI_ARGS_((ClientData clientData,
  41.                 Tcl_Interp *interp, char *name1, char *name2,
  42.                 int flags));
  43.  
  44. /*
  45.  *----------------------------------------------------------------------
  46.  *
  47.  * Tcl_RegexpCmd --
  48.  *
  49.  *    This procedure is invoked to process the "regexp" Tcl command.
  50.  *    See the user documentation for details on what it does.
  51.  *
  52.  * Results:
  53.  *    A standard Tcl result.
  54.  *
  55.  * Side effects:
  56.  *    See the user documentation.
  57.  *
  58.  *----------------------------------------------------------------------
  59.  */
  60.  
  61.     /* ARGSUSED */
  62. int
  63. Tcl_RegexpCmd(dummy, interp, argc, argv)
  64.     ClientData dummy;            /* Not used. */
  65.     Tcl_Interp *interp;            /* Current interpreter. */
  66.     int argc;                /* Number of arguments. */
  67.     char **argv;            /* Argument strings. */
  68. {
  69.     int noCase = 0;
  70.     int indices = 0;
  71.     regexp *regexpPtr;
  72.     char **argPtr, *string;
  73.     int match, i;
  74.  
  75.     if (argc < 3) {
  76.     wrongNumArgs:
  77.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  78.         " ?-nocase? exp string ?matchVar? ?subMatchVar ",
  79.         "subMatchVar ...?\"", (char *) NULL);
  80.     return TCL_ERROR;
  81.     }
  82.     argPtr = argv+1;
  83.     argc--;
  84.     while ((argc > 0) && (argPtr[0][0] == '-')) {
  85.     if (strcmp(argPtr[0], "-indices") == 0) {
  86.         argPtr++;
  87.         argc--;
  88.         indices = 1;
  89.     } else if (strcmp(argPtr[0], "-nocase") == 0) {
  90.         argPtr++;
  91.         argc--;
  92.         noCase = 1;
  93.     } else {
  94.         break;
  95.     }
  96.     }
  97.     if (argc < 2) {
  98.     goto wrongNumArgs;
  99.     }
  100.     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  101.     if (regexpPtr == NULL) {
  102.     return TCL_ERROR;
  103.     }
  104.  
  105.     /*
  106.      * Convert the string to lower case, if desired, and perform
  107.      * the match.
  108.      */
  109.  
  110.     if (noCase) {
  111.     register char *dst, *src;
  112.  
  113.     string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  114.     for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  115.         if (isupper(*src)) {
  116.         *dst = tolower(*src);
  117.         } else {
  118.         *dst = *src;
  119.         }
  120.     }
  121.     *dst = 0;
  122.     } else {
  123.     string = argPtr[1];
  124.     }
  125.     tclRegexpError = NULL;
  126.     match = regexec(regexpPtr, string);
  127.     if (string != argPtr[1]) {
  128.     ckfree(string);
  129.     }
  130.     if (tclRegexpError != NULL) {
  131.     Tcl_AppendResult(interp, "error while matching pattern: ",
  132.         tclRegexpError, (char *) NULL);
  133.     return TCL_ERROR;
  134.     }
  135.     if (!match) {
  136.     interp->result = "0";
  137.     return TCL_OK;
  138.     }
  139.  
  140.     /*
  141.      * If additional variable names have been specified, return
  142.      * index information in those variables.
  143.      */
  144.  
  145.     argc -= 2;
  146.     if (argc > NSUBEXP) {
  147.     interp->result = "too many substring variables";
  148.     return TCL_ERROR;
  149.     }
  150.     for (i = 0; i < argc; i++) {
  151.     char *result, info[50];
  152.  
  153.     if (regexpPtr->startp[i] == NULL) {
  154.         if (indices) {
  155.         result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
  156.         } else {
  157.         result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
  158.         }
  159.     } else {
  160.         if (indices) {
  161.         sprintf(info, "%d %d", regexpPtr->startp[i] - string,
  162.             regexpPtr->endp[i] - string - 1);
  163.         result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
  164.         } else {
  165.         char savedChar, *first, *last;
  166.  
  167.         first = argPtr[1] + (regexpPtr->startp[i] - string);
  168.         last = argPtr[1] + (regexpPtr->endp[i] - string);
  169.         savedChar = *last;
  170.         *last = 0;
  171.         result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
  172.         *last = savedChar;
  173.         }
  174.     }
  175.     if (result == NULL) {
  176.         Tcl_AppendResult(interp, "couldn't set variable \"",
  177.             argPtr[i+2], "\"", (char *) NULL);
  178.         return TCL_ERROR;
  179.     }
  180.     }
  181.     interp->result = "1";
  182.     return TCL_OK;
  183. }
  184.  
  185. /*
  186.  *----------------------------------------------------------------------
  187.  *
  188.  * Tcl_RegsubCmd --
  189.  *
  190.  *    This procedure is invoked to process the "regsub" Tcl command.
  191.  *    See the user documentation for details on what it does.
  192.  *
  193.  * Results:
  194.  *    A standard Tcl result.
  195.  *
  196.  * Side effects:
  197.  *    See the user documentation.
  198.  *
  199.  *----------------------------------------------------------------------
  200.  */
  201.  
  202.     /* ARGSUSED */
  203. int
  204. Tcl_RegsubCmd(dummy, interp, argc, argv)
  205.     ClientData dummy;            /* Not used. */
  206.     Tcl_Interp *interp;            /* Current interpreter. */
  207.     int argc;                /* Number of arguments. */
  208.     char **argv;            /* Argument strings. */
  209. {
  210.     int noCase = 0, all = 0;
  211.     regexp *regexpPtr;
  212.     char *string, *p, *firstChar, *newValue, **argPtr;
  213.     int match, result, flags;
  214.     register char *src, c;
  215.  
  216.     if (argc < 5) {
  217.     wrongNumArgs:
  218.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  219.         " ?-nocase? ?-all? exp string subSpec varName\"", (char *) NULL);
  220.     return TCL_ERROR;
  221.     }
  222.     argPtr = argv+1;
  223.     argc--;
  224.     while (argPtr[0][0] == '-') {
  225.     if (strcmp(argPtr[0], "-nocase") == 0) {
  226.         argPtr++;
  227.         argc--;
  228.         noCase = 1;
  229.     } else if (strcmp(argPtr[0], "-all") == 0) {
  230.         argPtr++;
  231.         argc--;
  232.         all = 1;
  233.     } else {
  234.         break;
  235.     }
  236.     }
  237.     if (argc != 4) {
  238.     goto wrongNumArgs;
  239.     }
  240.     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  241.     if (regexpPtr == NULL) {
  242.     return TCL_ERROR;
  243.     }
  244.  
  245.     /*
  246.      * Convert the string to lower case, if desired.
  247.      */
  248.  
  249.     if (noCase) {
  250.     register char *dst;
  251.  
  252.     string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  253.     for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  254.         if (isupper(*src)) {
  255.         *dst = tolower(*src);
  256.         } else {
  257.         *dst = *src;
  258.         }
  259.     }
  260.     *dst = 0;
  261.     } else {
  262.     string = argPtr[1];
  263.     }
  264.  
  265.     /*
  266.      * The following loop is to handle multiple matches within the
  267.      * same source string;  each iteration handles one match and its
  268.      * corresponding substitution.  If "-all" hasn't been specified
  269.      * then the loop body only gets executed once.
  270.      */
  271.  
  272.     flags = 0;
  273.     for (p = string; *p != 0; ) {
  274.     tclRegexpError = NULL;
  275.     match = regexec(regexpPtr, p);
  276.     if (tclRegexpError != NULL) {
  277.         Tcl_AppendResult(interp, "error while matching pattern: ",
  278.             tclRegexpError, (char *) NULL);
  279.         result = TCL_ERROR;
  280.         goto done;
  281.     }
  282.     if (!match) {
  283.         break;
  284.     }
  285.  
  286.     /*
  287.      * Copy the portion of the source string before the match to the
  288.      * result variable.
  289.      */
  290.     
  291.     src = argPtr[1] + (regexpPtr->startp[0] - string);
  292.     c = *src;
  293.     *src = 0;
  294.     newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
  295.         flags);
  296.     *src = c;
  297.     flags = TCL_APPEND_VALUE;
  298.     if (newValue == NULL) {
  299.         cantSet:
  300.         Tcl_AppendResult(interp, "couldn't set variable \"",
  301.             argPtr[3], "\"", (char *) NULL);
  302.         result = TCL_ERROR;
  303.         goto done;
  304.     }
  305.     
  306.     /*
  307.      * Append the subSpec argument to the variable, making appropriate
  308.      * substitutions.  This code is a bit hairy because of the backslash
  309.      * conventions and because the code saves up ranges of characters in
  310.      * subSpec to reduce the number of calls to Tcl_SetVar.
  311.      */
  312.     
  313.     for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
  314.         int index;
  315.     
  316.         if (c == '&') {
  317.         index = 0;
  318.         } else if (c == '\\') {
  319.         c = src[1];
  320.         if ((c >= '0') && (c <= '9')) {
  321.             index = c - '0';
  322.         } else if ((c == '\\') || (c == '&')) {
  323.             *src = c;
  324.             src[1] = 0;
  325.             newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  326.                 TCL_APPEND_VALUE);
  327.             *src = '\\';
  328.             src[1] = c;
  329.             if (newValue == NULL) {
  330.             goto cantSet;
  331.             }
  332.             firstChar = src+2;
  333.             src++;
  334.             continue;
  335.         } else {
  336.             continue;
  337.         }
  338.         } else {
  339.         continue;
  340.         }
  341.         if (firstChar != src) {
  342.         c = *src;
  343.         *src = 0;
  344.         newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  345.             TCL_APPEND_VALUE);
  346.         *src = c;
  347.         if (newValue == NULL) {
  348.             goto cantSet;
  349.         }
  350.         }
  351.         if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)
  352.             && (regexpPtr->endp[index] != NULL)) {
  353.         char *first, *last, saved;
  354.     
  355.         first = argPtr[1] + (regexpPtr->startp[index] - string);
  356.         last = argPtr[1] + (regexpPtr->endp[index] - string);
  357.         saved = *last;
  358.         *last = 0;
  359.         newValue = Tcl_SetVar(interp, argPtr[3], first,
  360.             TCL_APPEND_VALUE);
  361.         *last = saved;
  362.         if (newValue == NULL) {
  363.             goto cantSet;
  364.         }
  365.         }
  366.         if (*src == '\\') {
  367.         src++;
  368.         }
  369.         firstChar = src+1;
  370.     }
  371.     if (firstChar != src) {
  372.         if (Tcl_SetVar(interp, argPtr[3], firstChar,
  373.             TCL_APPEND_VALUE) == NULL) {
  374.         goto cantSet;
  375.         }
  376.     }
  377.     p = regexpPtr->endp[0];
  378.     if (!all) {
  379.         break;
  380.     }
  381.     }
  382.  
  383.     /*
  384.      * If there were no matches at all, then return a "0" result.
  385.      */
  386.  
  387.     if (p == string) {
  388.     interp->result = "0";
  389.     result = TCL_OK;
  390.     goto done;
  391.     }
  392.  
  393.     /*
  394.      * Copy the portion of the source string after the last match to the
  395.      * result variable.
  396.      */
  397.  
  398.     if (*p != 0) {
  399.     if (Tcl_SetVar(interp, argPtr[3], p, TCL_APPEND_VALUE) == NULL) {
  400.         goto cantSet;
  401.     }
  402.     }
  403.     interp->result = "1";
  404.     result = TCL_OK;
  405.  
  406.     done:
  407.     if (string != argPtr[1]) {
  408.     ckfree(string);
  409.     }
  410.     return result;
  411. }
  412.  
  413. /*
  414.  *----------------------------------------------------------------------
  415.  *
  416.  * Tcl_RenameCmd --
  417.  *
  418.  *    This procedure is invoked to process the "rename" Tcl command.
  419.  *    See the user documentation for details on what it does.
  420.  *
  421.  * Results:
  422.  *    A standard Tcl result.
  423.  *
  424.  * Side effects:
  425.  *    See the user documentation.
  426.  *
  427.  *----------------------------------------------------------------------
  428.  */
  429.  
  430.     /* ARGSUSED */
  431. int
  432. Tcl_RenameCmd(dummy, interp, argc, argv)
  433.     ClientData dummy;            /* Not used. */
  434.     Tcl_Interp *interp;            /* Current interpreter. */
  435.     int argc;                /* Number of arguments. */
  436.     char **argv;            /* Argument strings. */
  437. {
  438.     register Command *cmdPtr;
  439.     Interp *iPtr = (Interp *) interp;
  440.     Tcl_HashEntry *hPtr;
  441.     int new;
  442.  
  443.     if (argc != 3) {
  444.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  445.         " oldName newName\"", (char *) NULL);
  446.     return TCL_ERROR;
  447.     }
  448.     if (argv[2][0] == '\0') {
  449.     if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
  450.         Tcl_AppendResult(interp, "can't delete \"", argv[1],
  451.             "\": command doesn't exist", (char *) NULL);
  452.         return TCL_ERROR;
  453.     }
  454.     return TCL_OK;
  455.     }
  456.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
  457.     if (hPtr != NULL) {
  458.     Tcl_AppendResult(interp, "can't rename to \"", argv[2],
  459.         "\": command already exists", (char *) NULL);
  460.     return TCL_ERROR;
  461.     }
  462.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);
  463.     if (hPtr == NULL) {
  464.     Tcl_AppendResult(interp, "can't rename \"", argv[1],
  465.         "\":  command doesn't exist", (char *) NULL);
  466.     return TCL_ERROR;
  467.     }
  468.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  469.     Tcl_DeleteHashEntry(hPtr);
  470.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);
  471.     Tcl_SetHashValue(hPtr, cmdPtr);
  472.     return TCL_OK;
  473. }
  474.  
  475. /*
  476.  *----------------------------------------------------------------------
  477.  *
  478.  * Tcl_ReturnCmd --
  479.  *
  480.  *    This procedure is invoked to process the "return" Tcl command.
  481.  *    See the user documentation for details on what it does.
  482.  *
  483.  * Results:
  484.  *    A standard Tcl result.
  485.  *
  486.  * Side effects:
  487.  *    See the user documentation.
  488.  *
  489.  *----------------------------------------------------------------------
  490.  */
  491.  
  492.     /* ARGSUSED */
  493. int
  494. Tcl_ReturnCmd(dummy, interp, argc, argv)
  495.     ClientData dummy;            /* Not used. */
  496.     Tcl_Interp *interp;            /* Current interpreter. */
  497.     int argc;                /* Number of arguments. */
  498.     char **argv;            /* Argument strings. */
  499. {
  500.     if (argc > 2) {
  501.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  502.         " ?value?\"", (char *) NULL);
  503.     return TCL_ERROR;
  504.     }
  505.     if (argc == 2) {
  506.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  507.     }
  508.     return TCL_RETURN;
  509. }
  510.  
  511. /*
  512.  *----------------------------------------------------------------------
  513.  *
  514.  * Tcl_ScanCmd --
  515.  *
  516.  *    This procedure is invoked to process the "scan" Tcl command.
  517.  *    See the user documentation for details on what it does.
  518.  *
  519.  * Results:
  520.  *    A standard Tcl result.
  521.  *
  522.  * Side effects:
  523.  *    See the user documentation.
  524.  *
  525.  *----------------------------------------------------------------------
  526.  */
  527.  
  528.     /* ARGSUSED */
  529. int
  530. Tcl_ScanCmd(dummy, interp, argc, argv)
  531.     ClientData dummy;            /* Not used. */
  532.     Tcl_Interp *interp;            /* Current interpreter. */
  533.     int argc;                /* Number of arguments. */
  534.     char **argv;            /* Argument strings. */
  535. {
  536.     int arg1Length;            /* Number of bytes in argument to be
  537.                      * scanned.  This gives an upper limit
  538.                      * on string field sizes. */
  539. #   define MAX_FIELDS 20
  540.     typedef struct {
  541.     char fmt;            /* Format for field. */
  542.     int size;            /* How many bytes to allow for
  543.                      * field. */
  544.     char *location;            /* Where field will be stored. */
  545.     } Field;
  546.     Field fields[MAX_FIELDS];        /* Info about all the fields in the
  547.                      * format string. */
  548.     register Field *curField;
  549.     int numFields = 0;            /* Number of fields actually
  550.                      * specified. */
  551.     int suppress;            /* Current field is assignment-
  552.                      * suppressed. */
  553.     int totalSize = 0;            /* Number of bytes needed to store
  554.                      * all results combined. */
  555.     char *results;            /* Where scanned output goes.  */
  556.     int numScanned;            /* sscanf's result. */
  557.     register char *fmt;
  558.     int i, widthSpecified;
  559.  
  560.     if (argc < 3) {
  561.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  562.         " string format ?varName varName ...?\"", (char *) NULL);
  563.     return TCL_ERROR;
  564.     }
  565.  
  566.     /*
  567.      * This procedure operates in four stages:
  568.      * 1. Scan the format string, collecting information about each field.
  569.      * 2. Allocate an array to hold all of the scanned fields.
  570.      * 3. Call sscanf to do all the dirty work, and have it store the
  571.      *    parsed fields in the array.
  572.      * 4. Pick off the fields from the array and assign them to variables.
  573.      */
  574.  
  575.     arg1Length = (strlen(argv[1]) + 4) & ~03;
  576.     for (fmt = argv[2]; *fmt != 0; fmt++) {
  577.     if (*fmt != '%') {
  578.         continue;
  579.     }
  580.     fmt++;
  581.     if (*fmt == '*') {
  582.         suppress = 1;
  583.         fmt++;
  584.     } else {
  585.         suppress = 0;
  586.     }
  587.     widthSpecified = 0;
  588.     while (isdigit(*fmt)) {
  589.         widthSpecified = 1;
  590.         fmt++;
  591.     }
  592.     if (suppress) {
  593.         continue;
  594.     }
  595.     if (numFields == MAX_FIELDS) {
  596.         interp->result = "too many fields to scan";
  597.         return TCL_ERROR;
  598.     }
  599.     curField = &fields[numFields];
  600.     numFields++;
  601.     switch (*fmt) {
  602.         case 'D':
  603.         case 'O':
  604.         case 'X':
  605.         case 'd':
  606.         case 'o':
  607.         case 'x':
  608.         curField->fmt = 'd';
  609.         curField->size = sizeof(int);
  610.         break;
  611.  
  612.         case 's':
  613.         curField->fmt = 's';
  614.         curField->size = arg1Length;
  615.         break;
  616.  
  617.         case 'c':
  618.                 if (widthSpecified) {
  619.                     interp->result = 
  620.                          "field width may not be specified in %c conversion";
  621.                     return TCL_ERROR;
  622.                 }
  623.         curField->fmt = 'c';
  624.         curField->size = sizeof(int);
  625.         break;
  626.  
  627.         case 'E':
  628.         case 'F':
  629.         curField->fmt = 'F';
  630.         curField->size = sizeof(double);
  631.         break;
  632.  
  633.         case 'e':
  634.         case 'f':
  635.         curField->fmt = 'f';
  636.         curField->size = sizeof(float);
  637.         break;
  638.  
  639.         case '[':
  640.         curField->fmt = 's';
  641.         curField->size = arg1Length;
  642.         do {
  643.             fmt++;
  644.         } while (*fmt != ']');
  645.         break;
  646.  
  647.         default:
  648.         sprintf(interp->result, "bad scan conversion character \"%c\"",
  649.             *fmt);
  650.         return TCL_ERROR;
  651.     }
  652.     totalSize += curField->size;
  653.     }
  654.  
  655.     if (numFields != (argc-3)) {
  656.     interp->result =
  657.         "different numbers of variable names and field specifiers";
  658.     return TCL_ERROR;
  659.     }
  660.  
  661.     /*
  662.      * Step 2:
  663.      */
  664.  
  665.     results = (char *) ckalloc((unsigned) totalSize);
  666.     for (i = 0, totalSize = 0, curField = fields;
  667.         i < numFields; i++, curField++) {
  668.     curField->location = results + totalSize;
  669.     totalSize += curField->size;
  670.     }
  671.  
  672.     /*
  673.      * Fill in the remaining fields with NULL;  the only purpose of
  674.      * this is to keep some memory analyzers, like Purify, from
  675.      * complaining.
  676.      */
  677.  
  678.     for ( ; i < MAX_FIELDS; i++, curField++) {
  679.     curField->location = NULL;
  680.     }
  681.  
  682.     /*
  683.      * Step 3:
  684.      */
  685.  
  686.     numScanned = sscanf(argv[1], argv[2],
  687.         fields[0].location, fields[1].location, fields[2].location,
  688.         fields[3].location, fields[4].location, fields[5].location,
  689.         fields[6].location, fields[7].location, fields[8].location,
  690.         fields[9].location, fields[10].location, fields[11].location,
  691.         fields[12].location, fields[13].location, fields[14].location,
  692.         fields[15].location, fields[16].location, fields[17].location,
  693.         fields[18].location, fields[19].location);
  694.  
  695.     /*
  696.      * Step 4:
  697.      */
  698.  
  699.     if (numScanned < numFields) {
  700.     numFields = numScanned;
  701.     }
  702.     for (i = 0, curField = fields; i < numFields; i++, curField++) {
  703.     switch (curField->fmt) {
  704.         char string[120];
  705.  
  706.         case 'd':
  707.         sprintf(string, "%d", *((int *) curField->location));
  708.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  709.             storeError:
  710.             Tcl_AppendResult(interp,
  711.                 "couldn't set variable \"", argv[i+3], "\"",
  712.                 (char *) NULL);
  713.             ckfree((char *) results);
  714.             return TCL_ERROR;
  715.         }
  716.         break;
  717.  
  718.         case 'c':
  719.         sprintf(string, "%d", *((char *) curField->location) & 0xff);
  720.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  721.             goto storeError;
  722.         }
  723.         break;
  724.  
  725.         case 's':
  726.         if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
  727.             == NULL) {
  728.             goto storeError;
  729.         }
  730.         break;
  731.  
  732.         case 'F':
  733.         sprintf(string, "%g", *((double *) curField->location));
  734.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  735.             goto storeError;
  736.         }
  737.         break;
  738.  
  739.         case 'f':
  740.         sprintf(string, "%g", *((float *) curField->location));
  741.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  742.             goto storeError;
  743.         }
  744.         break;
  745.     }
  746.     }
  747.     ckfree(results);
  748.     sprintf(interp->result, "%d", numScanned);
  749.     return TCL_OK;
  750. }
  751.  
  752. /*
  753.  *----------------------------------------------------------------------
  754.  *
  755.  * Tcl_SplitCmd --
  756.  *
  757.  *    This procedure is invoked to process the "split" Tcl command.
  758.  *    See the user documentation for details on what it does.
  759.  *
  760.  * Results:
  761.  *    A standard Tcl result.
  762.  *
  763.  * Side effects:
  764.  *    See the user documentation.
  765.  *
  766.  *----------------------------------------------------------------------
  767.  */
  768.  
  769.     /* ARGSUSED */
  770. int
  771. Tcl_SplitCmd(dummy, interp, argc, argv)
  772.     ClientData dummy;            /* Not used. */
  773.     Tcl_Interp *interp;            /* Current interpreter. */
  774.     int argc;                /* Number of arguments. */
  775.     char **argv;            /* Argument strings. */
  776. {
  777.     char *splitChars;
  778.     register char *p, *p2;
  779.     char *elementStart;
  780.  
  781.     if (argc == 2) {
  782.     splitChars = " \n\t\r";
  783.     } else if (argc == 3) {
  784.     splitChars = argv[2];
  785.     } else {
  786.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  787.         " string ?splitChars?\"", (char *) NULL);
  788.     return TCL_ERROR;
  789.     }
  790.  
  791.     /*
  792.      * Handle the special case of splitting on every character.
  793.      */
  794.  
  795.     if (*splitChars == 0) {
  796.     char string[2];
  797.     string[1] = 0;
  798.     for (p = argv[1]; *p != 0; p++) {
  799.         string[0] = *p;
  800.         Tcl_AppendElement(interp, string, 0);
  801.     }
  802.     return TCL_OK;
  803.     }
  804.  
  805.     /*
  806.      * Normal case: split on any of a given set of characters.
  807.      * Discard instances of the split characters.
  808.      */
  809.  
  810.     for (p = elementStart = argv[1]; *p != 0; p++) {
  811.     char c = *p;
  812.     for (p2 = splitChars; *p2 != 0; p2++) {
  813.         if (*p2 == c) {
  814.         *p = 0;
  815.         Tcl_AppendElement(interp, elementStart, 0);
  816.         *p = c;
  817.         elementStart = p+1;
  818.         break;
  819.         }
  820.     }
  821.     }
  822.     if (p != argv[1]) {
  823.     Tcl_AppendElement(interp, elementStart, 0);
  824.     }
  825.     return TCL_OK;
  826. }
  827.  
  828. /*
  829.  *----------------------------------------------------------------------
  830.  *
  831.  * Tcl_StringCmd --
  832.  *
  833.  *    This procedure is invoked to process the "string" Tcl command.
  834.  *    See the user documentation for details on what it does.
  835.  *
  836.  * Results:
  837.  *    A standard Tcl result.
  838.  *
  839.  * Side effects:
  840.  *    See the user documentation.
  841.  *
  842.  *----------------------------------------------------------------------
  843.  */
  844.  
  845.     /* ARGSUSED */
  846. int
  847. Tcl_StringCmd(dummy, interp, argc, argv)
  848.     ClientData dummy;            /* Not used. */
  849.     Tcl_Interp *interp;            /* Current interpreter. */
  850.     int argc;                /* Number of arguments. */
  851.     char **argv;            /* Argument strings. */
  852. {
  853.     int length;
  854.     register char *p, c;
  855.     int match;
  856.     int first;
  857.     int left = 0, right = 0;
  858.  
  859.     if (argc < 2) {
  860.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  861.         " option arg ?arg ...?\"", (char *) NULL);
  862.     return TCL_ERROR;
  863.     }
  864.     c = argv[1][0];
  865.     length = strlen(argv[1]);
  866.     if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {
  867.     if (argc != 4) {
  868.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  869.             " compare string1 string2\"", (char *) NULL);
  870.         return TCL_ERROR;
  871.     }
  872.     match = strcmp(argv[2], argv[3]);
  873.     if (match > 0) {
  874.         interp->result = "1";
  875.     } else if (match < 0) {
  876.         interp->result = "-1";
  877.     } else {
  878.         interp->result = "0";
  879.     }
  880.     return TCL_OK;
  881.     } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {
  882.     if (argc != 4) {
  883.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  884.             " first string1 string2\"", (char *) NULL);
  885.         return TCL_ERROR;
  886.     }
  887.     first = 1;
  888.  
  889.     firstLast:
  890.     match = -1;
  891.     c = *argv[2];
  892.     length = strlen(argv[2]);
  893.     for (p = argv[3]; *p != 0; p++) {
  894.         if (*p != c) {
  895.         continue;
  896.         }
  897.         if (strncmp(argv[2], p, length) == 0) {
  898.         match = p-argv[3];
  899.         if (first) {
  900.             break;
  901.         }
  902.         }
  903.     }
  904.     sprintf(interp->result, "%d", match);
  905.     return TCL_OK;
  906.     } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
  907.     int index;
  908.  
  909.     if (argc != 4) {
  910.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  911.             " index string charIndex\"", (char *) NULL);
  912.         return TCL_ERROR;
  913.     }
  914.     if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
  915.         return TCL_ERROR;
  916.     }
  917.     if ((index >= 0) && (index < strlen(argv[2]))) {
  918.         interp->result[0] = argv[2][index];
  919.         interp->result[1] = 0;
  920.     }
  921.     return TCL_OK;
  922.     } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)
  923.         && (length >= 2)) {
  924.     if (argc != 4) {
  925.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  926.             " last string1 string2\"", (char *) NULL);
  927.         return TCL_ERROR;
  928.     }
  929.     first = 0;
  930.     goto firstLast;
  931.     } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)
  932.         && (length >= 2)) {
  933.     if (argc != 3) {
  934.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  935.             " length string\"", (char *) NULL);
  936.         return TCL_ERROR;
  937.     }
  938.     sprintf(interp->result, "%d", strlen(argv[2]));
  939.     return TCL_OK;
  940.     } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {
  941.     if (argc != 4) {
  942.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  943.             " match pattern string\"", (char *) NULL);
  944.         return TCL_ERROR;
  945.     }
  946.     if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
  947.         interp->result = "1";
  948.     } else {
  949.         interp->result = "0";
  950.     }
  951.     return TCL_OK;
  952.     } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
  953.     int first, last, stringLength;
  954.  
  955.     if (argc != 5) {
  956.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  957.             " range string first last\"", (char *) NULL);
  958.         return TCL_ERROR;
  959.     }
  960.     stringLength = strlen(argv[2]);
  961.     if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
  962.         return TCL_ERROR;
  963.     }
  964.     if ((*argv[4] == 'e')
  965.         && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
  966.         last = stringLength-1;
  967.     } else {
  968.         if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
  969.         Tcl_ResetResult(interp);
  970.         Tcl_AppendResult(interp,
  971.             "expected integer or \"end\" but got \"",
  972.             argv[4], "\"", (char *) NULL);
  973.         return TCL_ERROR;
  974.         }
  975.     }
  976.     if (first < 0) {
  977.         first = 0;
  978.     }
  979.     if (last >= stringLength) {
  980.         last = stringLength-1;
  981.     }
  982.     if (last >= first) {
  983.         char saved, *p;
  984.  
  985.         p = argv[2] + last + 1;
  986.         saved = *p;
  987.         *p = 0;
  988.         Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
  989.         *p = saved;
  990.     }
  991.     return TCL_OK;
  992.     } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
  993.         && (length >= 3)) {
  994.     register char *p;
  995.  
  996.     if (argc != 3) {
  997.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  998.             " tolower string\"", (char *) NULL);
  999.         return TCL_ERROR;
  1000.     }
  1001.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1002.     for (p = interp->result; *p != 0; p++) {
  1003.         if (isupper(*p)) {
  1004.         *p = tolower(*p);
  1005.         }
  1006.     }
  1007.     return TCL_OK;
  1008.     } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
  1009.         && (length >= 3)) {
  1010.     register char *p;
  1011.  
  1012.     if (argc != 3) {
  1013.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1014.             " toupper string\"", (char *) NULL);
  1015.         return TCL_ERROR;
  1016.     }
  1017.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1018.     for (p = interp->result; *p != 0; p++) {
  1019.         if (islower(*p)) {
  1020.         *p = toupper(*p);
  1021.         }
  1022.     }
  1023.     return TCL_OK;
  1024.     } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
  1025.         && (length == 4)) {
  1026.     char *trimChars;
  1027.     register char *p, *checkPtr;
  1028.  
  1029.     left = right = 1;
  1030.  
  1031.     trim:
  1032.     if (argc == 4) {
  1033.         trimChars = argv[3];
  1034.     } else if (argc == 3) {
  1035.         trimChars = " \t\n\r";
  1036.     } else {
  1037.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1038.             " ", argv[1], " string ?chars?\"", (char *) NULL);
  1039.         return TCL_ERROR;
  1040.     }
  1041.     p = argv[2];
  1042.     if (left) {
  1043.         for (c = *p; c != 0; p++, c = *p) {
  1044.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1045.             if (*checkPtr == 0) {
  1046.             goto doneLeft;
  1047.             }
  1048.         }
  1049.         }
  1050.     }
  1051.     doneLeft:
  1052.     Tcl_SetResult(interp, p, TCL_VOLATILE);
  1053.     if (right) {
  1054.         char *donePtr;
  1055.  
  1056.         p = interp->result + strlen(interp->result) - 1;
  1057.         donePtr = &interp->result[-1];
  1058.         for (c = *p; p != donePtr; p--, c = *p) {
  1059.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1060.             if (*checkPtr == 0) {
  1061.             goto doneRight;
  1062.             }
  1063.         }
  1064.         }
  1065.         doneRight:
  1066.         p[1] = 0;
  1067.     }
  1068.     return TCL_OK;
  1069.     } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
  1070.         && (length > 4)) {
  1071.     left = 1;
  1072.     argv[1] = "trimleft";
  1073.     goto trim;
  1074.     } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
  1075.         && (length > 4)) {
  1076.     right = 1;
  1077.     argv[1] = "trimright";
  1078.     goto trim;
  1079.     } else {
  1080.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1081.         "\": should be compare, first, index, last, length, match, ",
  1082.         "range, tolower, toupper, trim, trimleft, or trimright",
  1083.         (char *) NULL);
  1084.     return TCL_ERROR;
  1085.     }
  1086. }
  1087.  
  1088. /*
  1089.  *----------------------------------------------------------------------
  1090.  *
  1091.  * Tcl_TraceCmd --
  1092.  *
  1093.  *    This procedure is invoked to process the "trace" Tcl command.
  1094.  *    See the user documentation for details on what it does.
  1095.  *
  1096.  * Results:
  1097.  *    A standard Tcl result.
  1098.  *
  1099.  * Side effects:
  1100.  *    See the user documentation.
  1101.  *
  1102.  *----------------------------------------------------------------------
  1103.  */
  1104.  
  1105.     /* ARGSUSED */
  1106. int
  1107. Tcl_TraceCmd(dummy, interp, argc, argv)
  1108.     ClientData dummy;            /* Not used. */
  1109.     Tcl_Interp *interp;            /* Current interpreter. */
  1110.     int argc;                /* Number of arguments. */
  1111.     char **argv;            /* Argument strings. */
  1112. {
  1113.     char c;
  1114.     int length;
  1115.  
  1116.     if (argc < 2) {
  1117.     Tcl_AppendResult(interp, "too few args: should be \"",
  1118.         argv[0], " option [arg arg ...]\"", (char *) NULL);
  1119.     return TCL_ERROR;
  1120.     }
  1121.     c = argv[1][1];
  1122.     length = strlen(argv[1]);
  1123.     if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
  1124.         && (length >= 2)) {
  1125.     char *p;
  1126.     int flags, length;
  1127.     TraceVarInfo *tvarPtr;
  1128.  
  1129.     if (argc != 5) {
  1130.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1131.             argv[0], " variable name ops command\"", (char *) NULL);
  1132.         return TCL_ERROR;
  1133.     }
  1134.  
  1135.     flags = 0;
  1136.     for (p = argv[3] ; *p != 0; p++) {
  1137.         if (*p == 'r') {
  1138.         flags |= TCL_TRACE_READS;
  1139.         } else if (*p == 'w') {
  1140.         flags |= TCL_TRACE_WRITES;
  1141.         } else if (*p == 'u') {
  1142.         flags |= TCL_TRACE_UNSETS;
  1143.         } else {
  1144.         goto badOps;
  1145.         }
  1146.     }
  1147.     if (flags == 0) {
  1148.         goto badOps;
  1149.     }
  1150.  
  1151.     length = strlen(argv[4]);
  1152.     tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
  1153.         (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
  1154.     tvarPtr->flags = flags;
  1155.     tvarPtr->length = length;
  1156.     flags |= TCL_TRACE_UNSETS;
  1157.     strcpy(tvarPtr->command, argv[4]);
  1158.     if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
  1159.         (ClientData) tvarPtr) != TCL_OK) {
  1160.         ckfree((char *) tvarPtr);
  1161.         return TCL_ERROR;
  1162.     }
  1163.     } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
  1164.         && (length >= 2)) == 0) {
  1165.     char *p;
  1166.     int flags, length;
  1167.     TraceVarInfo *tvarPtr;
  1168.     ClientData clientData;
  1169.  
  1170.     if (argc != 5) {
  1171.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1172.             argv[0], " vdelete name ops command\"", (char *) NULL);
  1173.         return TCL_ERROR;
  1174.     }
  1175.  
  1176.     flags = 0;
  1177.     for (p = argv[3] ; *p != 0; p++) {
  1178.         if (*p == 'r') {
  1179.         flags |= TCL_TRACE_READS;
  1180.         } else if (*p == 'w') {
  1181.         flags |= TCL_TRACE_WRITES;
  1182.         } else if (*p == 'u') {
  1183.         flags |= TCL_TRACE_UNSETS;
  1184.         } else {
  1185.         goto badOps;
  1186.         }
  1187.     }
  1188.     if (flags == 0) {
  1189.         goto badOps;
  1190.     }
  1191.  
  1192.     /*
  1193.      * Search through all of our traces on this variable to
  1194.      * see if there's one with the given command.  If so, then
  1195.      * delete the first one that matches.
  1196.      */
  1197.  
  1198.     length = strlen(argv[4]);
  1199.     clientData = 0;
  1200.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1201.         TraceVarProc, clientData)) != 0) {
  1202.         tvarPtr = (TraceVarInfo *) clientData;
  1203.         if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
  1204.             && (strncmp(argv[4], tvarPtr->command, length) == 0)) {
  1205.         Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
  1206.             TraceVarProc, clientData);
  1207.         ckfree((char *) tvarPtr);
  1208.         break;
  1209.         }
  1210.     }
  1211.     } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
  1212.         && (length >= 2)) {
  1213.     ClientData clientData;
  1214.     char ops[4], *p;
  1215.     char *prefix = "{";
  1216.  
  1217.     if (argc != 3) {
  1218.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1219.             argv[0], " vinfo name\"", (char *) NULL);
  1220.         return TCL_ERROR;
  1221.     }
  1222.     clientData = 0;
  1223.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1224.         TraceVarProc, clientData)) != 0) {
  1225.         TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1226.         p = ops;
  1227.         if (tvarPtr->flags & TCL_TRACE_READS) {
  1228.         *p = 'r';
  1229.         p++;
  1230.         }
  1231.         if (tvarPtr->flags & TCL_TRACE_WRITES) {
  1232.         *p = 'w';
  1233.         p++;
  1234.         }
  1235.         if (tvarPtr->flags & TCL_TRACE_UNSETS) {
  1236.         *p = 'u';
  1237.         p++;
  1238.         }
  1239.         *p = '\0';
  1240.         Tcl_AppendResult(interp, prefix, (char *) NULL);
  1241.         Tcl_AppendElement(interp, ops, 1);
  1242.         Tcl_AppendElement(interp, tvarPtr->command, 0);
  1243.         Tcl_AppendResult(interp, "}", (char *) NULL);
  1244.         prefix = " {";
  1245.     }
  1246.     } else {
  1247.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1248.         "\": should be variable, vdelete, or vinfo",
  1249.         (char *) NULL);
  1250.     return TCL_ERROR;
  1251.     }
  1252.     return TCL_OK;
  1253.  
  1254.     badOps:
  1255.     Tcl_AppendResult(interp, "bad operations \"", argv[3],
  1256.         "\": should be one or more of rwu", (char *) NULL);
  1257.     return TCL_ERROR;
  1258. }
  1259.  
  1260. /*
  1261.  *----------------------------------------------------------------------
  1262.  *
  1263.  * TraceVarProc --
  1264.  *
  1265.  *    This procedure is called to handle variable accesses that have
  1266.  *    been traced using the "trace" command.
  1267.  *
  1268.  * Results:
  1269.  *    Normally returns NULL.  If the trace command returns an error,
  1270.  *    then this procedure returns an error string.
  1271.  *
  1272.  * Side effects:
  1273.  *    Depends on the command associated with the trace.
  1274.  *
  1275.  *----------------------------------------------------------------------
  1276.  */
  1277.  
  1278.     /* ARGSUSED */
  1279. static char *
  1280. TraceVarProc(clientData, interp, name1, name2, flags)
  1281.     ClientData clientData;    /* Information about the variable trace. */
  1282.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1283.     char *name1;        /* Name of variable or array. */
  1284.     char *name2;        /* Name of element within array;  NULL means
  1285.                  * scalar variable is being referenced. */
  1286.     int flags;            /* OR-ed bits giving operation and other
  1287.                  * information. */
  1288. {
  1289.     TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1290.     char *result;
  1291.     int code, cmdLength, flags1, flags2;
  1292.     Interp dummy;
  1293. #define STATIC_SIZE 199
  1294.     char staticSpace[STATIC_SIZE+1];
  1295.     char *cmdPtr, *p;
  1296.  
  1297.     result = NULL;
  1298.     if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
  1299.  
  1300.     /*
  1301.      * Generate a command to execute by appending list elements
  1302.      * for the two variable names and the operation.  The five
  1303.      * extra characters are for three space, the opcode character,
  1304.      * and the terminating null.
  1305.      */
  1306.  
  1307.     if (name2 == NULL) {
  1308.         name2 = "";
  1309.     }
  1310.     cmdLength = tvarPtr->length + Tcl_ScanElement(name1, &flags1) +
  1311.         Tcl_ScanElement(name2, &flags2) + 5;
  1312.     if (cmdLength < STATIC_SIZE) {
  1313.         cmdPtr = staticSpace;
  1314.     } else {
  1315.         cmdPtr = (char *) ckalloc((unsigned) cmdLength);
  1316.     }
  1317.     p = cmdPtr;
  1318.     strcpy(p, tvarPtr->command);
  1319.     p += tvarPtr->length;
  1320.     *p = ' ';
  1321.     p++;
  1322.     p += Tcl_ConvertElement(name1, p, flags1);
  1323.     *p = ' ';
  1324.     p++;
  1325.     p += Tcl_ConvertElement(name2, p, flags2);
  1326.     *p = ' ';
  1327.     if (flags & TCL_TRACE_READS) {
  1328.         p[1] = 'r';
  1329.     } else if (flags & TCL_TRACE_WRITES) {
  1330.         p[1] = 'w';
  1331.     } else if (flags & TCL_TRACE_UNSETS) {
  1332.         p[1] = 'u';
  1333.     }
  1334.     p[2] = '\0';
  1335.  
  1336.     /*
  1337.      * Execute the command.  Be careful to save and restore the
  1338.      * result from the interpreter used for the command.
  1339.      */
  1340.  
  1341.     if (interp->freeProc == 0) {
  1342.         dummy.freeProc = (Tcl_FreeProc *) 0;
  1343.         dummy.result = "";
  1344.         Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
  1345.     } else {
  1346.         dummy.freeProc = interp->freeProc;
  1347.         dummy.result = interp->result;
  1348.     }
  1349.     code = Tcl_Eval(interp, cmdPtr, 0, (char **) NULL);
  1350.     if (cmdPtr != staticSpace) {
  1351.         ckfree(cmdPtr);
  1352.     }
  1353.     if (code != TCL_OK) {
  1354.         result = "access disallowed by trace command";
  1355.         Tcl_ResetResult(interp);        /* Must clear error state. */
  1356.     }
  1357.     Tcl_FreeResult(interp);
  1358.     interp->result = dummy.result;
  1359.     interp->freeProc = dummy.freeProc;
  1360.     }
  1361.     if (flags & TCL_TRACE_DESTROYED) {
  1362.     ckfree((char *) tvarPtr);
  1363.     }
  1364.     return result;
  1365. }
  1366.  
  1367. /*
  1368.  *----------------------------------------------------------------------
  1369.  *
  1370.  * Tcl_WhileCmd --
  1371.  *
  1372.  *    This procedure is invoked to process the "while" Tcl command.
  1373.  *    See the user documentation for details on what it does.
  1374.  *
  1375.  * Results:
  1376.  *    A standard Tcl result.
  1377.  *
  1378.  * Side effects:
  1379.  *    See the user documentation.
  1380.  *
  1381.  *----------------------------------------------------------------------
  1382.  */
  1383.  
  1384.     /* ARGSUSED */
  1385. int
  1386. Tcl_WhileCmd(dummy, interp, argc, argv)
  1387.     ClientData dummy;            /* Not used. */
  1388.     Tcl_Interp *interp;            /* Current interpreter. */
  1389.     int argc;                /* Number of arguments. */
  1390.     char **argv;            /* Argument strings. */
  1391. {
  1392.     int result, value;
  1393.  
  1394.     if (argc != 3) {
  1395.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1396.         argv[0], " test command\"", (char *) NULL);
  1397.     return TCL_ERROR;
  1398.     }
  1399.  
  1400.     while (1) {
  1401.     result = Tcl_ExprBoolean(interp, argv[1], &value);
  1402.     if (result != TCL_OK) {
  1403.         return result;
  1404.     }
  1405.     if (!value) {
  1406.         break;
  1407.     }
  1408.     result = Tcl_Eval(interp, argv[2], 0, (char **) NULL);
  1409.     if (result == TCL_CONTINUE) {
  1410.         result = TCL_OK;
  1411.     } else if (result != TCL_OK) {
  1412.         if (result == TCL_ERROR) {
  1413.         char msg[60];
  1414.         sprintf(msg, "\n    (\"while\" body line %d)",
  1415.             interp->errorLine);
  1416.         Tcl_AddErrorInfo(interp, msg);
  1417.         }
  1418.         break;
  1419.     }
  1420.     }
  1421.     if (result == TCL_BREAK) {
  1422.     result = TCL_OK;
  1423.     }
  1424.     if (result == TCL_OK) {
  1425.     Tcl_ResetResult(interp);
  1426.     }
  1427.     return result;
  1428. }
  1429.